home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Workbench Add-On
/
Workbench Add-On - Volume 1.iso
/
Dev
/
Oberon
/
source
/
ProjectOberon
/
AmigaSupport.mod
< prev
next >
Wrap
Text File
|
1995-07-02
|
8KB
|
282 lines
(*************************************************************************
$RCSfile: AmigaSupport.mod $
Description: Amiga-specific support for Project Oberon modules.
Created by: fjc (Frank Copeland)
$Revision: 1.3 $
$Author: fjc $
$Date: 1995/06/04 23:24:07 $
Copyright © 1995, Frank Copeland.
This file is part of the Oberon-A Library.
See Oberon-A.doc for conditions of use and distribution.
*************************************************************************)
<*STANDARD-*> <* MAIN-*>
MODULE AmigaSupport;
IMPORT
SYS := SYSTEM, Kernel, Errors, s := Sets, e := Exec, es := ExecSupport,
u := Utility, gfx := Graphics, i := Intuition, gt := GadTools,
ASL, rt := ReqTools, iu := IntuiUtil, df := DiskFont;
(*------------------------------------*)
VAR
scr -: i.ScreenPtr;
scrFont -: gfx.TextFontPtr;
win -: i.WindowPtr;
W -, H -: INTEGER;
KeyProc*, MouseProc*, TickProc* : PROCEDURE (msg : i.IntuiMessagePtr);
oldRegion : gfx.RegionPtr; (* for clipping *)
screenDrawInfo : i.DrawInfoPtr;
attr : gfx.TextAttr;
(*------------------------------------*)
CONST
pubScreenName = "";
scrTitle = "Display inactive";
winTitle = "Display for Project Oberon modules";
idcmp = {i.vanillaKey, i.mouseButtons, i.intuiTicks};
(*------------------------------------*)
PROCEDURE OpenScreen;
(*------------------------------------*)
PROCEDURE CloneScreen;
VAR
screenModeID : LONGINT;
pubScreen : i.ScreenPtr;
BEGIN (* CloneScreen *)
scrFont := NIL;
pubScreen := i.LockPubScreen (pubScreenName);
IF pubScreen # NIL THEN
screenDrawInfo := i.GetScreenDrawInfo (pubScreen);
IF screenDrawInfo # NIL THEN
screenModeID := gfx.GetVPModeID (SYS.ADR (pubScreen.viewPort));
IF screenModeID # gfx.invalidID THEN
scr := i.OpenScreenTagsA
( NIL,
i.saWidth, pubScreen.width,
i.saHeight, pubScreen.height,
i.saDepth, screenDrawInfo.depth,
i.saOverscan, i.oScanText,
i.saAutoScroll, i.LTRUE,
i.saFullPalette, i.LTRUE,
i.saPens, screenDrawInfo.pens,
i.saSysFont, 1,
i.saDisplayID, screenModeID,
i.saTitle, SYS.ADR (scrTitle),
u.end );
i.FreeScreenDrawInfo (pubScreen, screenDrawInfo);
screenDrawInfo := NIL;
i.UnlockPubScreen (pubScreenName, pubScreen);
pubScreen := NIL;
IF scr # NIL THEN
screenDrawInfo := i.GetScreenDrawInfo (scr);
IF screenDrawInfo # NIL THEN scrFont := screenDrawInfo.font
ELSE scrFont := gfx.base.defaultFont
END
END
END
END
END;
ASSERT (scr # NIL, Errors.postCondition)
END CloneScreen;
(*------------------------------------*)
PROCEDURE ReqToolsScreen;
VAR
scrMdReq : rt.ScreenModeRequesterPtr; result : BOOLEAN;
displayID, autoScroll : LONGINT;
displayWidth, displayHeight, displayDepth(*, overscanType*) : INTEGER;
fontReq : rt.FontRequesterPtr;
(*attr : gfx.TextAttr;*) fontTag : u.TagID; fontData : u.Tag;
BEGIN (* ReqToolsScreen *)
scrMdReq :=
SYS.VAL (rt.ScreenModeRequesterPtr,
rt.AllocRequest ( rt.TypeScreenModeReq, u.end ));
ASSERT (scrMdReq # NIL, Errors.postCondition);
result :=
rt.ScreenModeRequest
( scrMdReq, "Choose a screen mode",
rt.scFlags, { rt.scReqSizeGads, rt.scReqDepthGad,
rt.scReqGuiModes, rt.scReqAutoscrollGad },
u.end );
IF result THEN
displayID := scrMdReq.displayID;
displayWidth := scrMdReq.displayWidth;
displayHeight := scrMdReq.displayHeight;
displayDepth := scrMdReq.displayDepth;
(* overscanType := scrMdReq.overscanType; *)
autoScroll := scrMdReq.autoScroll;
rt.FreeRequest (scrMdReq);
fontReq :=
SYS.VAL (rt.FontRequesterPtr,
rt.AllocRequest ( rt.TypeFontReq, u.end ));
ASSERT (fontReq # NIL, Errors.postCondition);
result := rt.FontRequest ( fontReq, "Choose a font", u.end );
IF result THEN
attr := fontReq.attr;
SYS.NEW (attr.name, SYS.STRLEN (fontReq.attr.name^) + 1);
COPY (fontReq.attr.name^, attr.name^);
fontTag := i.saFont; fontData := SYS.ADR (attr)
ELSE
fontTag := i.saSysFont; fontData := 1
END;
rt.FreeRequest (fontReq);
scr := i.OpenScreenTagsA
( NIL,
i.saWidth, displayWidth,
i.saHeight, displayHeight,
i.saDepth, displayDepth,
i.saAutoScroll, autoScroll,
i.saDisplayID, displayID,
fontTag, fontData,
i.saTitle, SYS.ADR (scrTitle),
(* i.saOverscan, overscanType, *)
i.saOverscan, i.oScanText,
i.saFullPalette, i.LTRUE,
u.end )
ELSE
rt.FreeRequest (scrMdReq);
CloneScreen
END;
ASSERT (scr # NIL, Errors.postCondition)
END ReqToolsScreen;
BEGIN (* OpenScreen *)
rt.OpenLib (FALSE);
IF rt.base # NIL THEN ReqToolsScreen
ELSE CloneScreen
END;
screenDrawInfo := i.GetScreenDrawInfo (scr);
IF screenDrawInfo # NIL THEN scrFont := screenDrawInfo.font
ELSE scrFont := gfx.base.defaultFont
END
END OpenScreen;
(*------------------------------------*)
PROCEDURE CloseScreen ();
BEGIN (* CloseScreen *)
IF scr # NIL THEN
IF screenDrawInfo # NIL THEN
i.FreeScreenDrawInfo (scr, screenDrawInfo); screenDrawInfo := NIL
END;
i.OldCloseScreen (scr); scr := NIL
END
END CloseScreen;
(*------------------------------------*)
PROCEDURE OpenWindow ();
BEGIN (* OpenWindow *)
win := i.OpenWindowTagsA ( NIL,
i.waCustomScreen, scr,
i.waTop, scr.barHeight + scr.barVBorder,
i.waHeight, scr.height - scr.barHeight - scr.barVBorder,
i.waActivate, i.LTRUE,
i.waBorderless, i.LTRUE,
i.waBackdrop, i.LTRUE,
i.waRMBTrap, i.LTRUE,
i.waScreenTitle, SYS.ADR (winTitle),
i.waIDCMP, idcmp,
u.end );
ASSERT (win # NIL, Errors.postCondition);
ASSERT (iu.ClipWindowToBorders (win, oldRegion), Errors.postCondition)
END OpenWindow;
(*------------------------------------*)
PROCEDURE CloseWindow ();
BEGIN (* CloseWindow *)
IF win # NIL THEN
iu.UnclipWindow (win, oldRegion); oldRegion := NIL;
i.CloseWindow (win); win := NIL
END;
END CloseWindow;
(*------------------------------------*)
PROCEDURE OpenDisplay *;
BEGIN (* OpenDisplay *)
IF scr = NIL THEN
OpenScreen();
OpenWindow();
W := win.width - win.borderLeft - win.borderRight;
H := win.height - win.borderTop - win.borderBottom;
END
END OpenDisplay;
(*------------------------------------*)
PROCEDURE GetNextEvent*;
VAR
msg : i.IntuiMessagePtr;
signals : s.SET32;
sigBit : SHORTINT;
BEGIN (* GetNextEvent *)
(* We only have one signal bit, so we do not have to check which
** bit broke the Wait().
*)
signals := e.Wait ({win.userPort.sigBit});
LOOP
msg := SYS.VAL (i.IntuiMessagePtr, e.GetMsg (win.userPort));
IF msg = NIL THEN EXIT END;
IF (msg.class = {i.vanillaKey})
OR (msg.class = {i.rawKey})
THEN
IF KeyProc # NIL THEN KeyProc (msg) END;
ELSIF msg.class = {i.mouseButtons} THEN
IF MouseProc # NIL THEN MouseProc (msg) END;
ELSIF msg.class = {i.intuiTicks} THEN
IF TickProc # NIL THEN TickProc (msg) END;
END;
e.ReplyMsg (msg)
END;
END GetNextEvent;
(*------------------------------------*)
PROCEDURE BeginUpdate*;
BEGIN (* BeginUpdate *)
END BeginUpdate;
(*------------------------------------*)
PROCEDURE EndUpdate*;
BEGIN (* EndUpdate *)
END EndUpdate;
(*------------------------------------*)
PROCEDURE* Close ( VAR rc : LONGINT );
BEGIN (* Close *)
CloseWindow();
CloseScreen();
END Close;
(*------------------------------------*)
<*$ClearVars+*>
BEGIN
Errors.Init;
ASSERT (gt.base # NIL, 100);
Kernel.SetCleanup (Close)
END AmigaSupport.